home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / shwpcx10.zip / SHOWPCX.PAS < prev    next >
Pascal/Delphi Source File  |  1991-12-30  |  28KB  |  810 lines
  1. Program showpcx;
  2. { Free Software by TapirSoft Gisbert W.Selke, Dec 1991                       }
  3. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,V- }
  4. {$M 65520,0,128000 }
  5.  
  6. {$UNDEF DEBUG }     { DEFINE while debugging }
  7.  
  8. {$IFDEF DEBUG }
  9. {$R+,S+ }
  10. {$ELSE }
  11. {$R-,S- }
  12. {$ENDIF }
  13.  
  14.   Uses Graph, CRT, Dos;
  15.  
  16.   Const progname = 'ShowPCX';
  17.         version  = '1.0';
  18.         copyright= 'Free Software by TapirSoft Gisbert W.Selke, Dec 1991';
  19.  
  20.         bufsize  = 60000;
  21.         maxlinlen= 2048; { maximum length of screen line }
  22.         Tab      = #9;
  23.         finishset: Set Of char = [#3,#27,'q','Q'];
  24.  
  25.   Type headrec = Record
  26.                    id           : byte;  { must be $0A }
  27.                    version      : byte;  { 0, 2, 3, or 5 }
  28.                    compr        : byte;  { 1 if RLE-coded }
  29.                    bitsperpixel : byte;
  30.                    xmin         : word;
  31.                    ymin         : word;
  32.                    xmax         : word;
  33.                    ymax         : word;
  34.                    horidpi      : word; { horizontal resolution, dots per inch }
  35.                    vertdpi      : word; { vertical   resolution, dots per inch }
  36.                    colormap     : Array [0..15,0..2] Of byte;
  37.                    reserved     : byte;
  38.                    ncolplanes   : byte; { number of colour planes; max 4 }
  39.                    bytesperline : word; { must be even }
  40.                    greyscale    : word; { 1 if colour or b/w; 2 if greyscale }
  41.                    filler       : Array [1..58] Of byte;
  42.                  End;
  43.        buffer   = Array [1..bufsize ] Of byte;
  44.        linbuffer= Array [0..maxlinlen] Of byte;
  45.  
  46.   Var listf : text;
  47.       inbufptr : ^buffer;
  48.       sr : SearchRec;
  49.       saveexit : Pointer;
  50.       dir, picname : string;
  51.       grdriver, grmode : integer;
  52.       maxx, maxy, maxcolour, deltime : word;
  53.       parampt, xscale, yscale, videomode : byte;
  54.       zverbose, zxcentre, zycentre, zprop, zmono, zconj, zebra : boolean;
  55.       zquiet, zgraph, zlist, zfirst, zfinish, zfound, zrepeat : boolean;
  56.  
  57.   { Link in graphics drivers for EGA, VGA and Hercules: }
  58.   Procedure egavga_driver; External;
  59.   {$L EGAVGA.OBJ }
  60.   Procedure svga256_driver; External;
  61.   {$L SVGA256.OBJ }
  62.   Procedure herc_driver; External;
  63.   {$L HERC.OBJ }
  64.  
  65. {$F+} function DetectVGA256 : integer; {$F-}
  66. var
  67.   DetectedDriver : integer;
  68.   SuggestedMode  : integer;
  69. begin
  70.   DetectGraph(DetectedDriver, SuggestedMode);
  71.   DetectVGA256 := SuggestedMode;
  72.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  73.     DetectVGA256 := 0        { Default video mode = 0 }
  74.   else
  75.     DetectVGA256 := grError; { Couldn't detect hardware }
  76. end; { DetectVGA256 }
  77.  
  78.   {$F+ } Procedure myexit; {$F- }
  79.   { exit procedure to clean things up                                        }
  80.     Var c : char;
  81.   Begin                                                             { myexit }
  82.     ExitProc := saveexit;
  83.     NoSound;
  84.     If zgraph Then
  85.     Begin
  86.       SetGraphMode(GetGraphMode);
  87.       CloseGraph;
  88.       zgraph := False;
  89.     End;
  90.     If Not zfound Then writeln('No matching PCX files found.');
  91.     While KeyPressed Do c := ReadKey;
  92.   End;                                                              { myexit }
  93.  
  94.   Procedure beep;
  95.   { emit a short beep                                                        }
  96.   Begin                                                               { beep }
  97.     If Not zquiet Then
  98.     Begin
  99.       Sound(440);
  100.       Delay(50);
  101.       NoSound;
  102.     End;
  103.   End;                                                                { beep }
  104.  
  105.   Procedure abort(msg : string; ierr : byte);
  106.   { show error message and die                                               }
  107.   Begin                                                              { abort }
  108.     If zgraph Then CloseGraph;
  109.     zgraph := False;
  110.     If msg <> '' Then writeln(progname,': ',msg);
  111.     Halt(ierr);
  112.   End;                                                               { abort }
  113.  
  114.   Procedure usage;
  115.   { show usage hints and die                                                 }
  116.   Begin                                                              { usage }
  117.     writeln;
  118.     writeln(progname,' ',version,': display PCX files on screen');
  119.     writeln(copyright);
  120.     writeln;
  121.     writeln('Usage: ',progname,'  [<options>] <filespec> [<filespec>...]');
  122.     writeln('       where <filespec> is the name of a PCX file, possibly ',
  123.             'containing');
  124.     writeln('             wildcard characters (default extension .PCX),');
  125.     writeln('       or "@", followed immediately by the name of a file ');
  126.     writeln('             containing names of PCX files.');
  127.     writeln('       Options: /c  : centre image');
  128.     writeln('                /cx : centre image horizontally');
  129.     writeln('                /cy : centre image vertically');
  130.     writeln('                /d<num>  : delay in milliseconds after each ',
  131.             'image');
  132.     writeln('                /e<num>  : extended VGA mode (use at your own ',
  133.             'risk!)');
  134.     writeln('                /h  : display help');
  135.     writeln('                /m  : force monochrome mode');
  136.     writeln('                /p  : use alternate packing strategy for scaling');
  137.     writeln('                /q  : quiet behaviour (don''t beep)');
  138.     writeln('                /r  : repeat indefinitely');
  139.     writeln('                /s<num>  : scale image by factor ',
  140.             '1/<num> (0 = autoscale)');
  141.     writeln('                /sx<num> : scale horizontally only');
  142.     writeln('                /sy<num> : scale vertically only');
  143.     writeln('                /v  : verbose image info');
  144.     writeln('                /z  : zebra monochrome mode');
  145.     zfound := True;
  146.     abort('',1);
  147.   End;                                                               { usage }
  148.  
  149.   Procedure strip(Var s : string);
  150.   { remove leading and trailing white space                                  }
  151.   Begin                                                              { strip }
  152.     While (s <> '') And (s[1] In [' ',Tab]) Do Delete(s,1,1);
  153.     While (s <> '') And (s[Length(s)] In [' ',Tab]) Do Delete(s,Length(s),1);
  154.   End;                                                               { strip }
  155.  
  156.   Function getnextname : string;
  157.   { get name of next file to display                                         }
  158.     Var temp, nam, ext : string;
  159.         doserr : integer;
  160.   Begin                                                        { getnextname }
  161.     sr.name := '';
  162.     doserr := 0;
  163.     If zfirst Then
  164.     Begin
  165.       temp := '';
  166.       While zlist And (temp = '') Do
  167.       Begin
  168.         If EoLn(listf) And (Not EoF(listf)) Then readln(listf);
  169.         If IOResult <> 0 Then;
  170.         If zlist And EoF(listf) Then
  171.         Begin
  172.           Close(listf);
  173.           Dispose(inbufptr);
  174.           zlist := False;
  175.         End;
  176.         If zlist Then read(listf,temp);
  177.         If IOResult <> 0 Then;
  178.         strip(temp);
  179.       End;
  180.       If temp = '' Then
  181.       Begin
  182.         While (temp = '') And (parampt <= ParamCount) Do
  183.         Begin
  184.           If (parampt = ParamCount) And zrepeat And zfound Then parampt := 0;
  185.           Inc(parampt);
  186.           If parampt <= ParamCount Then temp := ParamStr(parampt);
  187.           If temp[1] In ['-','/'] Then temp := '';
  188.         End;
  189.         If temp[1] = '@' Then
  190.         Begin
  191.           Assign(listf,Copy(temp,2,255));
  192.           Reset(listf);
  193.           If IOResult <> 0 Then;
  194.           New(inbufptr);
  195.           SetTextBuf(listf,inbufptr^);
  196.           zlist := True;
  197.           temp := getnextname;
  198.         End;
  199.       End;
  200.       If temp <> '' Then
  201.       Begin
  202.         FSplit(temp,dir,nam,ext);
  203.         If ext = '' Then ext := '.PCX';
  204.         temp := dir + nam + ext;
  205.         FindFirst(temp,ReadOnly+Hidden+SysFile+Archive,sr);
  206.         doserr := DosError;
  207.         If doserr = 0 Then zfound := True;
  208.         zfirst := False;
  209.       End
  210.       Else
  211.       Begin
  212.         dir := '';
  213.         sr.name := '';
  214.       End;
  215.     End
  216.     Else
  217.     Begin
  218.       FindNext(s